(* 
#use "pool.ml"
module P = Pool
#install_printer P.print_interval
P.initialize 3
let x1 = P.malloc()
let x2 = P.malloc()
let x3 = P.malloc()
let x4 = P.malloc()
let x5 = P.malloc()
let x6 = P.malloc()
let x7 = P.malloc()
let x8 = P.malloc()
P.free x1
P.free x2
P.free x3
P.free x4
P.free x5
P.free x6
P.free x7



let x1 = P.malloc()
let x' = P.interval x
P.set_interval x' (1.0,2.0)
x'

P.malloc()


*) 


module type POOL =
sig
  type interval
  val default : interval
  val print_interval : interval -> unit
  val set_interval : interval -> float * float -> unit

  type location 
  val interval : location -> interval

  type pool

  val initialize : default_size:int -> unit
  val malloc : unit -> location
  val free : location -> unit

end

module Pool : POOL =
struct 

  open Lib.Common

  type interval = {lo : float ref;
                   hi : float ref}

  let default = {lo = ref 0.0;
                 hi = ref 0.0}

  let print_interval {lo=lo;hi=hi} = print_pair print_float print_float (!lo,!hi)

  let set_interval {lo=lo;hi=hi} (x,y) = (lo:=x;hi:=y)

  type pool = {arr : interval array;
               active : int ref}

  type location = {pool : pool;
                   index : int;
                   (* debug *)
                   freed : bool ref}

  let default_size = ref 0

  let interval {pool=pool;index=index;freed=freed} = 
    if !freed then failwith "interval: serious error: examining freed memory" else
    pool.arr.(index)

  let new_pool() = {arr = Array.create !default_size default;
                    active = ref !default_size}

  (* global variable pointing to the next free interval *)
  let next = ref {pool = {arr = [||];active=ref 0};
                  index = 0;
                  freed = ref false}

  let initialize = 
    let initialized = ref false in
    let initialize ~default_size:size = 
      if !initialized then failwith "initialize: already initialized" else
      initialized := true;
      if size > 0 then 
      (default_size := size;
       next := {pool = new_pool();
                index = 0;
                freed = ref false})
      else failwith "initialize: bad input" in
      initialize

  let malloc() = 
    let ret = !next in
      begin 
        (if !next.index < !default_size - 1 then 
           begin 
             next := {pool = !next.pool;
                      index = !next.index + 1;
                      freed = ref false}
           end
         else 
           begin 
             print_stringl "creating new array...";
             next := {pool = new_pool() ;
                      index = 0;
                      freed = ref false};
           end);
        ret
      end

  let free {pool=pool;freed=freed} =
    begin 
      if !freed then failwith "free: serious error: freeing freed memory" else
      freed := true;
      decr pool.active;
      if !(pool.active) = 0 then print_stringl "freeing memory..." else ()
    end
                 
end
    





